home *** CD-ROM | disk | FTP | other *** search
/ PC World 2007 March / PCWorld_2007-03_cd.bin / domacnost a kancelar / scribus / scribus-1.3.3.7-win32-install.exe / tcl / tcl8.4 / safe.tcl < prev    next >
Text File  |  2004-07-02  |  28KB  |  925 lines
  1. # safe.tcl --
  2. #
  3. # This file provide a safe loading/sourcing mechanism for safe interpreters.
  4. # It implements a virtual path mecanism to hide the real pathnames from the
  5. # slave. It runs in a master interpreter and sets up data structure and
  6. # aliases that will be invoked when used from a slave interpreter.
  7. # 
  8. # See the safe.n man page for details.
  9. #
  10. # Copyright (c) 1996-1997 Sun Microsystems, Inc.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15. # RCS: @(#) $Id: safe.tcl,v 1.9.2.2 2004/06/29 09:39:01 dkf Exp $
  16.  
  17. #
  18. # The implementation is based on namespaces. These naming conventions
  19. # are followed:
  20. # Private procs starts with uppercase.
  21. # Public  procs are exported and starts with lowercase
  22. #
  23.  
  24. # Needed utilities package
  25. package require opt 0.4.1;
  26.  
  27. # Create the safe namespace
  28. namespace eval ::safe {
  29.  
  30.     # Exported API:
  31.     namespace export interpCreate interpInit interpConfigure interpDelete \
  32.         interpAddToAccessPath interpFindInAccessPath setLogCmd
  33.  
  34.     ####
  35.     #
  36.     # Setup the arguments parsing
  37.     #
  38.     ####
  39.  
  40.     # Make sure that our temporary variable is local to this
  41.     # namespace.  [Bug 981733]
  42.     variable temp
  43.  
  44.     # Share the descriptions
  45.     set temp [::tcl::OptKeyRegister {
  46.     {-accessPath -list {} "access path for the slave"}
  47.     {-noStatics "prevent loading of statically linked pkgs"}
  48.     {-statics true "loading of statically linked pkgs"}
  49.     {-nestedLoadOk "allow nested loading"}
  50.     {-nested false "nested loading"}
  51.     {-deleteHook -script {} "delete hook"}
  52.     }]
  53.  
  54.     # create case (slave is optional)
  55.     ::tcl::OptKeyRegister {
  56.     {?slave? -name {} "name of the slave (optional)"}
  57.     } ::safe::interpCreate
  58.     # adding the flags sub programs to the command program
  59.     # (relying on Opt's internal implementation details)
  60.     lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
  61.  
  62.     # init and configure (slave is needed)
  63.     ::tcl::OptKeyRegister {
  64.     {slave -name {} "name of the slave"}
  65.     } ::safe::interpIC
  66.     # adding the flags sub programs to the command program
  67.     # (relying on Opt's internal implementation details)
  68.     lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
  69.     # temp not needed anymore
  70.     ::tcl::OptKeyDelete $temp
  71.  
  72.  
  73.     # Helper function to resolve the dual way of specifying staticsok
  74.     # (either by -noStatics or -statics 0)
  75.     proc InterpStatics {} {
  76.     foreach v {Args statics noStatics} {
  77.         upvar $v $v
  78.     }
  79.     set flag [::tcl::OptProcArgGiven -noStatics];
  80.     if {$flag && ($noStatics == $statics) 
  81.               && ([::tcl::OptProcArgGiven -statics])} {
  82.         return -code error\
  83.             "conflicting values given for -statics and -noStatics"
  84.     }
  85.     if {$flag} {
  86.         return [expr {!$noStatics}]
  87.     } else {
  88.         return $statics
  89.     }
  90.     }
  91.  
  92.     # Helper function to resolve the dual way of specifying nested loading
  93.     # (either by -nestedLoadOk or -nested 1)
  94.     proc InterpNested {} {
  95.     foreach v {Args nested nestedLoadOk} {
  96.         upvar $v $v
  97.     }
  98.     set flag [::tcl::OptProcArgGiven -nestedLoadOk];
  99.     # note that the test here is the opposite of the "InterpStatics"
  100.     # one (it is not -noNested... because of the wanted default value)
  101.     if {$flag && ($nestedLoadOk != $nested) 
  102.               && ([::tcl::OptProcArgGiven -nested])} {
  103.         return -code error\
  104.             "conflicting values given for -nested and -nestedLoadOk"
  105.     }
  106.     if {$flag} {
  107.         # another difference with "InterpStatics"
  108.         return $nestedLoadOk
  109.     } else {
  110.         return $nested
  111.     }
  112.     }
  113.  
  114.     ####
  115.     #
  116.     #  API entry points that needs argument parsing :
  117.     #
  118.     ####
  119.  
  120.  
  121.     # Interface/entry point function and front end for "Create"
  122.     proc interpCreate {args} {
  123.     set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
  124.     InterpCreate $slave $accessPath \
  125.         [InterpStatics] [InterpNested] $deleteHook
  126.     }
  127.  
  128.     proc interpInit {args} {
  129.     set Args [::tcl::OptKeyParse ::safe::interpIC $args]
  130.     if {![::interp exists $slave]} {
  131.         return -code error "\"$slave\" is not an interpreter"
  132.     }
  133.     InterpInit $slave $accessPath \
  134.         [InterpStatics] [InterpNested] $deleteHook;
  135.     }
  136.  
  137.     proc CheckInterp {slave} {
  138.     if {![IsInterp $slave]} {
  139.         return -code error \
  140.             "\"$slave\" is not an interpreter managed by ::safe::"
  141.     }
  142.     }
  143.  
  144.     # Interface/entry point function and front end for "Configure"
  145.     # This code is awfully pedestrian because it would need
  146.     # more coupling and support between the way we store the
  147.     # configuration values in safe::interp's and the Opt package
  148.     # Obviously we would like an OptConfigure
  149.     # to avoid duplicating all this code everywhere. -> TODO
  150.     # (the app should share or access easily the program/value
  151.     #  stored by opt)
  152.     # This is even more complicated by the boolean flags with no values
  153.     # that we had the bad idea to support for the sake of user simplicity
  154.     # in create/init but which makes life hard in configure...
  155.     # So this will be hopefully written and some integrated with opt1.0
  156.     # (hopefully for tcl8.1 ?)
  157.     proc interpConfigure {args} {
  158.     switch [llength $args] {
  159.         1 {
  160.         # If we have exactly 1 argument
  161.         # the semantic is to return all the current configuration
  162.         # We still call OptKeyParse though we know that "slave"
  163.         # is our given argument because it also checks
  164.         # for the "-help" option.
  165.         set Args [::tcl::OptKeyParse ::safe::interpIC $args]
  166.         CheckInterp $slave
  167.         set res {}
  168.         lappend res [list -accessPath [Set [PathListName $slave]]]
  169.         lappend res [list -statics    [Set [StaticsOkName $slave]]]
  170.         lappend res [list -nested     [Set [NestedOkName $slave]]]
  171.         lappend res [list -deleteHook [Set [DeleteHookName $slave]]]
  172.         join $res
  173.         }
  174.         2 {
  175.         # If we have exactly 2 arguments
  176.         # the semantic is a "configure get"
  177.         ::tcl::Lassign $args slave arg
  178.         # get the flag sub program (we 'know' about Opt's internal
  179.         # representation of data)
  180.         set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
  181.         set hits [::tcl::OptHits desc $arg]
  182.                 if {$hits > 1} {
  183.                     return -code error [::tcl::OptAmbigous $desc $arg]
  184.                 } elseif {$hits == 0} {
  185.                     return -code error [::tcl::OptFlagUsage $desc $arg]
  186.                 }
  187.         CheckInterp $slave
  188.         set item [::tcl::OptCurDesc $desc]
  189.         set name [::tcl::OptName $item]
  190.         switch -exact -- $name {
  191.             -accessPath {
  192.             return [list -accessPath [Set [PathListName $slave]]]
  193.             }
  194.             -statics {
  195.             return [list -statics    [Set [StaticsOkName $slave]]]
  196.             }
  197.             -nested {
  198.             return [list -nested     [Set [NestedOkName $slave]]]
  199.             }
  200.             -deleteHook {
  201.             return [list -deleteHook [Set [DeleteHookName $slave]]]
  202.             }
  203.             -noStatics {
  204.             # it is most probably a set in fact
  205.             # but we would need then to jump to the set part
  206.             # and it is not *sure* that it is a set action
  207.             # that the user want, so force it to use the
  208.             # unambigous -statics ?value? instead:
  209.             return -code error\
  210.                 "ambigous query (get or set -noStatics ?)\
  211.                 use -statics instead"
  212.             }
  213.             -nestedLoadOk {
  214.             return -code error\
  215.                 "ambigous query (get or set -nestedLoadOk ?)\
  216.                 use -nested instead"
  217.             }
  218.             default {
  219.             return -code error "unknown flag $name (bug)"
  220.             }
  221.         }
  222.         }
  223.         default {
  224.         # Otherwise we want to parse the arguments like init and create
  225.         # did
  226.         set Args [::tcl::OptKeyParse ::safe::interpIC $args]
  227.         CheckInterp $slave
  228.         # Get the current (and not the default) values of
  229.         # whatever has not been given:
  230.         if {![::tcl::OptProcArgGiven -accessPath]} {
  231.             set doreset 1
  232.             set accessPath [Set [PathListName $slave]]
  233.         } else {
  234.             set doreset 0
  235.         }
  236.         if {(![::tcl::OptProcArgGiven -statics]) \
  237.             && (![::tcl::OptProcArgGiven -noStatics]) } {
  238.             set statics    [Set [StaticsOkName $slave]]
  239.         } else {
  240.             set statics    [InterpStatics]
  241.         }
  242.         if {([::tcl::OptProcArgGiven -nested]) \
  243.             || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
  244.             set nested     [InterpNested]
  245.         } else {
  246.             set nested     [Set [NestedOkName $slave]]
  247.         }
  248.         if {![::tcl::OptProcArgGiven -deleteHook]} {
  249.             set deleteHook [Set [DeleteHookName $slave]]
  250.         }
  251.         # we can now reconfigure :
  252.         InterpSetConfig $slave $accessPath $statics $nested $deleteHook
  253.         # auto_reset the slave (to completly synch the new access_path)
  254.         if {$doreset} {
  255.             if {[catch {::interp eval $slave {auto_reset}} msg]} {
  256.             Log $slave "auto_reset failed: $msg"
  257.             } else {
  258.             Log $slave "successful auto_reset" NOTICE
  259.             }
  260.         }
  261.         }
  262.     }
  263.     }
  264.  
  265.  
  266.     ####
  267.     #
  268.     #  Functions that actually implements the exported APIs
  269.     #
  270.     ####
  271.  
  272.  
  273.     #
  274.     # safe::InterpCreate : doing the real job
  275.     #
  276.     # This procedure creates a safe slave and initializes it with the
  277.     # safe base aliases.
  278.     # NB: slave name must be simple alphanumeric string, no spaces,
  279.     # no (), no {},...  {because the state array is stored as part of the name}
  280.     #
  281.     # Returns the slave name.
  282.     #
  283.     # Optional Arguments : 
  284.     # + slave name : if empty, generated name will be used
  285.     # + access_path: path list controlling where load/source can occur,
  286.     #                if empty: the master auto_path will be used.
  287.     # + staticsok  : flag, if 0 :no static package can be loaded (load {} Xxx)
  288.     #                      if 1 :static packages are ok.
  289.     # + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
  290.     #                      if 1 : multiple levels are ok.
  291.     
  292.     # use the full name and no indent so auto_mkIndex can find us
  293.     proc ::safe::InterpCreate {
  294.     slave 
  295.     access_path
  296.     staticsok
  297.     nestedok
  298.     deletehook
  299.     } {
  300.     # Create the slave.
  301.     if {$slave ne ""} {
  302.         ::interp create -safe $slave
  303.     } else {
  304.         # empty argument: generate slave name
  305.         set slave [::interp create -safe]
  306.     }
  307.     Log $slave "Created" NOTICE
  308.  
  309.     # Initialize it. (returns slave name)
  310.     InterpInit $slave $access_path $staticsok $nestedok $deletehook
  311.     }
  312.  
  313.  
  314.     #
  315.     # InterpSetConfig (was setAccessPath) :
  316.     #    Sets up slave virtual auto_path and corresponding structure
  317.     #    within the master. Also sets the tcl_library in the slave
  318.     #    to be the first directory in the path.
  319.     #    Nb: If you change the path after the slave has been initialized
  320.     #    you probably need to call "auto_reset" in the slave in order that it
  321.     #    gets the right auto_index() array values.
  322.  
  323.     proc ::safe::InterpSetConfig {slave access_path staticsok\
  324.         nestedok deletehook} {
  325.  
  326.     # determine and store the access path if empty
  327.     if {[string equal "" $access_path]} {
  328.         set access_path [uplevel \#0 set auto_path]
  329.         # Make sure that tcl_library is in auto_path
  330.         # and at the first position (needed by setAccessPath)
  331.         set where [lsearch -exact $access_path [info library]]
  332.         if {$where == -1} {
  333.         # not found, add it.
  334.         set access_path [concat [list [info library]] $access_path]
  335.         Log $slave "tcl_library was not in auto_path,\
  336.             added it to slave's access_path" NOTICE
  337.         } elseif {$where != 0} {
  338.         # not first, move it first
  339.         set access_path [concat [list [info library]]\
  340.             [lreplace $access_path $where $where]]
  341.         Log $slave "tcl_libray was not in first in auto_path,\
  342.             moved it to front of slave's access_path" NOTICE
  343.         
  344.         }
  345.  
  346.         # Add 1st level sub dirs (will searched by auto loading from tcl
  347.         # code in the slave using glob and thus fail, so we add them
  348.         # here so by default it works the same).
  349.         set access_path [AddSubDirs $access_path]
  350.     }
  351.  
  352.     Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
  353.         nestedok=$nestedok deletehook=($deletehook)" NOTICE
  354.  
  355.     # clear old autopath if it existed
  356.     set nname [PathNumberName $slave]
  357.     if {[Exists $nname]} {
  358.         set n [Set $nname]
  359.         for {set i 0} {$i<$n} {incr i} {
  360.         Unset [PathToken $i $slave]
  361.         }
  362.     }
  363.  
  364.     # build new one
  365.     set slave_auto_path {}
  366.     set i 0
  367.     foreach dir $access_path {
  368.         Set [PathToken $i $slave] $dir
  369.         lappend slave_auto_path "\$[PathToken $i]"
  370.         incr i
  371.     }
  372.     Set $nname $i
  373.     Set [PathListName $slave] $access_path
  374.     Set [VirtualPathListName $slave] $slave_auto_path
  375.  
  376.     Set [StaticsOkName $slave] $staticsok
  377.     Set [NestedOkName $slave] $nestedok
  378.     Set [DeleteHookName $slave] $deletehook
  379.  
  380.     SyncAccessPath $slave
  381.     }
  382.  
  383.     #
  384.     #
  385.     # FindInAccessPath:
  386.     #    Search for a real directory and returns its virtual Id
  387.     #    (including the "$")
  388. proc ::safe::interpFindInAccessPath {slave path} {
  389.     set access_path [GetAccessPath $slave]
  390.     set where [lsearch -exact $access_path $path]
  391.     if {$where == -1} {
  392.         return -code error "$path not found in access path $access_path"
  393.     }
  394.     return "\$[PathToken $where]"
  395.     }
  396.  
  397.     #
  398.     # addToAccessPath:
  399.     #    add (if needed) a real directory to access path
  400.     #    and return its virtual token (including the "$").
  401. proc ::safe::interpAddToAccessPath {slave path} {
  402.     # first check if the directory is already in there
  403.     if {![catch {interpFindInAccessPath $slave $path} res]} {
  404.         return $res
  405.     }
  406.     # new one, add it:
  407.     set nname [PathNumberName $slave]
  408.     set n [Set $nname]
  409.     Set [PathToken $n $slave] $path
  410.  
  411.     set token "\$[PathToken $n]"
  412.  
  413.     Lappend [VirtualPathListName $slave] $token
  414.     Lappend [PathListName $slave] $path
  415.     Set $nname [expr {$n+1}]
  416.  
  417.     SyncAccessPath $slave
  418.  
  419.     return $token
  420.     }
  421.  
  422.     # This procedure applies the initializations to an already existing
  423.     # interpreter. It is useful when you want to install the safe base
  424.     # aliases into a preexisting safe interpreter.
  425.     proc ::safe::InterpInit {
  426.     slave 
  427.     access_path
  428.     staticsok
  429.     nestedok
  430.     deletehook
  431.     } {
  432.  
  433.     # Configure will generate an access_path when access_path is
  434.     # empty.
  435.     InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
  436.  
  437.     # These aliases let the slave load files to define new commands
  438.  
  439.     # NB we need to add [namespace current], aliases are always
  440.     # absolute paths.
  441.     ::interp alias $slave source {} [namespace current]::AliasSource $slave
  442.     ::interp alias $slave load {} [namespace current]::AliasLoad $slave
  443.  
  444.     # This alias lets the slave use the encoding names, convertfrom,
  445.     # convertto, and system, but not "encoding system <name>" to set
  446.     # the system encoding.
  447.  
  448.     ::interp alias $slave encoding {} [namespace current]::AliasEncoding \
  449.         $slave
  450.  
  451.     # This alias lets the slave have access to a subset of the 'file'
  452.     # command functionality.
  453.  
  454.     AliasSubset $slave file file dir.* join root.* ext.* tail \
  455.         path.* split
  456.  
  457.     # This alias interposes on the 'exit' command and cleanly terminates
  458.     # the slave.
  459.  
  460.     ::interp alias $slave exit {} [namespace current]::interpDelete $slave
  461.  
  462.     # The allowed slave variables already have been set
  463.     # by Tcl_MakeSafe(3)
  464.  
  465.  
  466.     # Source init.tcl into the slave, to get auto_load and other
  467.     # procedures defined:
  468.  
  469.     # We don't try to use the -rsrc on the mac because it would get
  470.     # confusing if you would want to customize init.tcl
  471.     # for a given set of safe slaves, on all the platforms
  472.     # you just need to give a specific access_path and
  473.     # the mac should be no exception. As there is no
  474.     # obvious full "safe ressources" design nor implementation
  475.     # for the mac, safe interps there will just don't
  476.     # have that ability. (A specific app can still reenable
  477.     # that using custom aliases if they want to).
  478.     # It would also make the security analysis and the Safe Tcl security
  479.     # model platform dependant and thus more error prone.
  480.  
  481.     if {[catch {::interp eval $slave\
  482.         {source [file join $tcl_library init.tcl]}} msg]} {
  483.         Log $slave "can't source init.tcl ($msg)"
  484.         error "can't source init.tcl into slave $slave ($msg)"
  485.     }
  486.  
  487.     return $slave
  488.     }
  489.  
  490.  
  491.     # Add (only if needed, avoid duplicates) 1 level of
  492.     # sub directories to an existing path list.
  493.     # Also removes non directories from the returned list.
  494.     proc AddSubDirs {pathList} {
  495.     set res {}
  496.     foreach dir $pathList {
  497.         if {[file isdirectory $dir]} {
  498.         # check that we don't have it yet as a children
  499.         # of a previous dir
  500.         if {[lsearch -exact $res $dir]<0} {
  501.             lappend res $dir
  502.         }
  503.         foreach sub [glob -directory $dir -nocomplain *] {
  504.             if {([file isdirectory $sub]) \
  505.                 && ([lsearch -exact $res $sub]<0) } {
  506.             # new sub dir, add it !
  507.                     lappend res $sub
  508.                 }
  509.         }
  510.         }
  511.     }
  512.     return $res
  513.     }
  514.  
  515.     # This procedure deletes a safe slave managed by Safe Tcl and
  516.     # cleans up associated state:
  517.  
  518. proc ::safe::interpDelete {slave} {
  519.  
  520.         Log $slave "About to delete" NOTICE
  521.  
  522.     # If the slave has a cleanup hook registered, call it.
  523.     # check the existance because we might be called to delete an interp
  524.     # which has not been registered with us at all
  525.     set hookname [DeleteHookName $slave]
  526.     if {[Exists $hookname]} {
  527.         set hook [Set $hookname]
  528.         if {![::tcl::Lempty $hook]} {
  529.         # remove the hook now, otherwise if the hook
  530.         # calls us somehow, we'll loop
  531.         Unset $hookname
  532.         if {[catch {eval $hook [list $slave]} err]} {
  533.             Log $slave "Delete hook error ($err)"
  534.         }
  535.         }
  536.     }
  537.  
  538.     # Discard the global array of state associated with the slave, and
  539.     # delete the interpreter.
  540.  
  541.     set statename [InterpStateName $slave]
  542.     if {[Exists $statename]} {
  543.         Unset $statename
  544.     }
  545.  
  546.     # if we have been called twice, the interp might have been deleted
  547.     # already
  548.     if {[::interp exists $slave]} {
  549.         ::interp delete $slave
  550.         Log $slave "Deleted" NOTICE
  551.     }
  552.  
  553.     return
  554.     }
  555.  
  556.     # Set (or get) the loging mecanism 
  557.  
  558. proc ::safe::setLogCmd {args} {
  559.     variable Log
  560.     if {[llength $args] == 0} {
  561.     return $Log
  562.     } else {
  563.     if {[llength $args] == 1} {
  564.         set Log [lindex $args 0]
  565.     } else {
  566.         set Log $args
  567.     }
  568.     }
  569. }
  570.  
  571.     # internal variable
  572.     variable Log {}
  573.  
  574.     # ------------------- END OF PUBLIC METHODS ------------
  575.  
  576.  
  577.     #
  578.     # sets the slave auto_path to the master recorded value.
  579.     # also sets tcl_library to the first token of the virtual path.
  580.     #
  581.     proc SyncAccessPath {slave} {
  582.     set slave_auto_path [Set [VirtualPathListName $slave]]
  583.     ::interp eval $slave [list set auto_path $slave_auto_path]
  584.     Log $slave "auto_path in $slave has been set to $slave_auto_path"\
  585.         NOTICE
  586.     ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]
  587.     }
  588.  
  589.     # base name for storing all the slave states
  590.     # the array variable name for slave foo is thus "Sfoo"
  591.     # and for sub slave {foo bar} "Sfoo bar" (spaces are handled
  592.     # ok everywhere (or should))
  593.     # We add the S prefix to avoid that a slave interp called "Log"
  594.     # would smash our "Log" variable.
  595.     proc InterpStateName {slave} {
  596.     return "S$slave"
  597.     }
  598.  
  599.     # Check that the given slave is "one of us"
  600.     proc IsInterp {slave} {
  601.     expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}
  602.     }
  603.  
  604.     # returns the virtual token for directory number N
  605.     # if the slave argument is given, 
  606.     # it will return the corresponding master global variable name
  607.     proc PathToken {n {slave ""}} {
  608.     if {$slave ne ""} {
  609.         return "[InterpStateName $slave](access_path,$n)"
  610.     } else {
  611.         # We need to have a ":" in the token string so
  612.         # [file join] on the mac won't turn it into a relative
  613.         # path.
  614.         return "p(:$n:)"
  615.     }
  616.     }
  617.     # returns the variable name of the complete path list
  618.     proc PathListName {slave} {
  619.     return "[InterpStateName $slave](access_path)"
  620.     }
  621.     # returns the variable name of the complete path list
  622.     proc VirtualPathListName {slave} {
  623.     return "[InterpStateName $slave](access_path_slave)"
  624.     }
  625.     # returns the variable name of the number of items
  626.     proc PathNumberName {slave} {
  627.     return "[InterpStateName $slave](access_path,n)"
  628.     }
  629.     # returns the staticsok flag var name
  630.     proc StaticsOkName {slave} {
  631.     return "[InterpStateName $slave](staticsok)"
  632.     }
  633.     # returns the nestedok flag var name
  634.     proc NestedOkName {slave} {
  635.     return "[InterpStateName $slave](nestedok)"
  636.     }
  637.     # Run some code at the namespace toplevel
  638.     proc Toplevel {args} {
  639.     namespace eval [namespace current] $args
  640.     }
  641.     # set/get values
  642.     proc Set {args} {
  643.     eval [list Toplevel set] $args
  644.     }
  645.     # lappend on toplevel vars
  646.     proc Lappend {args} {
  647.     eval [list Toplevel lappend] $args
  648.     }
  649.     # unset a var/token (currently just an global level eval)
  650.     proc Unset {args} {
  651.     eval [list Toplevel unset] $args
  652.     }
  653.     # test existance 
  654.     proc Exists {varname} {
  655.     Toplevel info exists $varname
  656.     }
  657.     # short cut for access path getting
  658.     proc GetAccessPath {slave} {
  659.     Set [PathListName $slave]
  660.     }
  661.     # short cut for statics ok flag getting
  662.     proc StaticsOk {slave} {
  663.     Set [StaticsOkName $slave]
  664.     }
  665.     # short cut for getting the multiples interps sub loading ok flag
  666.     proc NestedOk {slave} {
  667.     Set [NestedOkName $slave]
  668.     }
  669.     # interp deletion storing hook name
  670.     proc DeleteHookName {slave} {
  671.     return [InterpStateName $slave](cleanupHook)
  672.     }
  673.  
  674.     #
  675.     # translate virtual path into real path
  676.     #
  677.     proc TranslatePath {slave path} {
  678.     # somehow strip the namespaces 'functionality' out (the danger
  679.     # is that we would strip valid macintosh "../" queries... :
  680.     if {[regexp {(::)|(\.\.)} $path]} {
  681.         error "invalid characters in path $path"
  682.     }
  683.     set n [expr {[Set [PathNumberName $slave]]-1}]
  684.     for {} {$n>=0} {incr n -1} {
  685.         # fill the token virtual names with their real value
  686.         set [PathToken $n] [Set [PathToken $n $slave]]
  687.     }
  688.     # replaces the token by their value
  689.     subst -nobackslashes -nocommands $path
  690.     }
  691.  
  692.  
  693.     # Log eventually log an error
  694.     # to enable error logging, set Log to {puts stderr} for instance
  695.     proc Log {slave msg {type ERROR}} {
  696.     variable Log
  697.     if {[info exists Log] && [llength $Log]} {
  698.         eval $Log [list "$type for slave $slave : $msg"]
  699.     }
  700.     }
  701.  
  702.  
  703.     # file name control (limit access to files/ressources that should be
  704.     # a valid tcl source file)
  705.     proc CheckFileName {slave file} {
  706.     # This used to limit what can be sourced to ".tcl" and forbid files
  707.     # with more than 1 dot and longer than 14 chars, but I changed that
  708.     # for 8.4 as a safe interp has enough internal protection already
  709.     # to allow sourcing anything. - hobbs
  710.  
  711.     if {![file exists $file]} {
  712.         # don't tell the file path
  713.         error "no such file or directory"
  714.     }
  715.  
  716.     if {![file readable $file]} {
  717.         # don't tell the file path
  718.         error "not readable"
  719.     }
  720.     }
  721.  
  722.  
  723.     # AliasSource is the target of the "source" alias in safe interpreters.
  724.  
  725.     proc AliasSource {slave args} {
  726.  
  727.     set argc [llength $args]
  728.     # Allow only "source filename"
  729.     # (and not mac specific -rsrc for instance - see comment in ::init
  730.     # for current rationale)
  731.     if {$argc != 1} {
  732.         set msg "wrong # args: should be \"source fileName\""
  733.         Log $slave "$msg ($args)"
  734.         return -code error $msg
  735.     }
  736.     set file [lindex $args 0]
  737.     
  738.     # get the real path from the virtual one.
  739.     if {[catch {set file [TranslatePath $slave $file]} msg]} {
  740.         Log $slave $msg
  741.         return -code error "permission denied"
  742.     }
  743.     
  744.     # check that the path is in the access path of that slave
  745.     if {[catch {FileInAccessPath $slave $file} msg]} {
  746.         Log $slave $msg
  747.         return -code error "permission denied"
  748.     }
  749.  
  750.     # do the checks on the filename :
  751.     if {[catch {CheckFileName $slave $file} msg]} {
  752.         Log $slave "$file:$msg"
  753.         return -code error $msg
  754.     }
  755.  
  756.     # passed all the tests , lets source it:
  757.     if {[catch {::interp invokehidden $slave source $file} msg]} {
  758.         Log $slave $msg
  759.         return -code error "script error"
  760.     }
  761.     return $msg
  762.     }
  763.  
  764.     # AliasLoad is the target of the "load" alias in safe interpreters.
  765.  
  766.     proc AliasLoad {slave file args} {
  767.  
  768.     set argc [llength $args]
  769.     if {$argc > 2} {
  770.         set msg "load error: too many arguments"
  771.         Log $slave "$msg ($argc) {$file $args}"
  772.         return -code error $msg
  773.     }
  774.  
  775.     # package name (can be empty if file is not).
  776.     set package [lindex $args 0]
  777.  
  778.     # Determine where to load. load use a relative interp path
  779.     # and {} means self, so we can directly and safely use passed arg.
  780.     set target [lindex $args 1]
  781.     if {[string length $target]} {
  782.         # we will try to load into a sub sub interp
  783.         # check that we want to authorize that.
  784.         if {![NestedOk $slave]} {
  785.         Log $slave "loading to a sub interp (nestedok)\
  786.             disabled (trying to load $package to $target)"
  787.         return -code error "permission denied (nested load)"
  788.         }
  789.         
  790.     }
  791.  
  792.     # Determine what kind of load is requested
  793.     if {[string length $file] == 0} {
  794.         # static package loading
  795.         if {[string length $package] == 0} {
  796.         set msg "load error: empty filename and no package name"
  797.         Log $slave $msg
  798.         return -code error $msg
  799.         }
  800.         if {![StaticsOk $slave]} {
  801.         Log $slave "static packages loading disabled\
  802.             (trying to load $package to $target)"
  803.         return -code error "permission denied (static package)"
  804.         }
  805.     } else {
  806.         # file loading
  807.  
  808.         # get the real path from the virtual one.
  809.         if {[catch {set file [TranslatePath $slave $file]} msg]} {
  810.         Log $slave $msg
  811.         return -code error "permission denied"
  812.         }
  813.  
  814.         # check the translated path
  815.         if {[catch {FileInAccessPath $slave $file} msg]} {
  816.         Log $slave $msg
  817.         return -code error "permission denied (path)"
  818.         }
  819.     }
  820.  
  821.     if {[catch {::interp invokehidden\
  822.         $slave load $file $package $target} msg]} {
  823.         Log $slave $msg
  824.         return -code error $msg
  825.     }
  826.  
  827.     return $msg
  828.     }
  829.  
  830.     # FileInAccessPath raises an error if the file is not found in
  831.     # the list of directories contained in the (master side recorded) slave's
  832.     # access path.
  833.  
  834.     # the security here relies on "file dirname" answering the proper
  835.     # result.... needs checking ?
  836.     proc FileInAccessPath {slave file} {
  837.  
  838.     set access_path [GetAccessPath $slave]
  839.  
  840.     if {[file isdirectory $file]} {
  841.         error "\"$file\": is a directory"
  842.     }
  843.     set parent [file dirname $file]
  844.  
  845.     # Normalize paths for comparison since lsearch knows nothing of
  846.     # potential pathname anomalies.
  847.     set norm_parent [file normalize $parent]
  848.     foreach path $access_path {
  849.         lappend norm_access_path [file normalize $path]
  850.     }
  851.  
  852.     if {[lsearch -exact $norm_access_path $norm_parent] == -1} {
  853.         error "\"$file\": not in access_path"
  854.     }
  855.     }
  856.  
  857.     # This procedure enables access from a safe interpreter to only a subset of
  858.     # the subcommands of a command:
  859.  
  860.     proc Subset {slave command okpat args} {
  861.     set subcommand [lindex $args 0]
  862.     if {[regexp $okpat $subcommand]} {
  863.         return [eval [list $command $subcommand] [lrange $args 1 end]]
  864.     }
  865.     set msg "not allowed to invoke subcommand $subcommand of $command"
  866.     Log $slave $msg
  867.     error $msg
  868.     }
  869.  
  870.     # This procedure installs an alias in a slave that invokes "safesubset"
  871.     # in the master to execute allowed subcommands. It precomputes the pattern
  872.     # of allowed subcommands; you can use wildcards in the pattern if you wish
  873.     # to allow subcommand abbreviation.
  874.     #
  875.     # Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
  876.  
  877.     proc AliasSubset {slave alias target args} {
  878.     set pat ^(; set sep ""
  879.     foreach sub $args {
  880.         append pat $sep$sub
  881.         set sep |
  882.     }
  883.     append pat )\$
  884.     ::interp alias $slave $alias {}\
  885.         [namespace current]::Subset $slave $target $pat
  886.     }
  887.  
  888.     # AliasEncoding is the target of the "encoding" alias in safe interpreters.
  889.  
  890.     proc AliasEncoding {slave args} {
  891.  
  892.     set argc [llength $args]
  893.  
  894.     set okpat "^(name.*|convert.*)\$"
  895.     set subcommand [lindex $args 0]
  896.  
  897.     if {[regexp $okpat $subcommand]} {
  898.         return [eval ::interp invokehidden $slave encoding $subcommand \
  899.             [lrange $args 1 end]]
  900.     }
  901.  
  902.     if {[string match $subcommand system]} {
  903.         if {$argc == 1} {
  904.         # passed all the tests , lets source it:
  905.         if {[catch {::interp invokehidden \
  906.             $slave encoding system} msg]} {
  907.             Log $slave $msg
  908.             return -code error "script error"
  909.         }
  910.         } else {
  911.         set msg "wrong # args: should be \"encoding system\""
  912.         Log $slave $msg
  913.         error $msg
  914.         }
  915.     } else {
  916.         set msg "wrong # args: should be \"encoding option ?arg ...?\""
  917.         Log $slave $msg
  918.         error $msg
  919.     }
  920.  
  921.     return $msg
  922.     }
  923.  
  924. }
  925.